Shareware Grab Bag/Shareware Grab Bag.iso/050/madtrb17.arc/SPELLER.PAS

Pascal/Delphi Source File | 1985-06-14 | 10KB | 320 lines

PROGRAM SPELLER;  { SPELL CHECKER -- with cmd line }

{   This spell checker is based on the ideas contained in PC-SPELL ver
    1.15 in BASIC by Andy Wildenberg. In that program the text file is
    read into memory and put into a list of words in a string array. The
    string array is then sorted and the unique words removed into
    another array. Thus a unique word array is formed which is in
    alphabetical order. This word list is then compared to a dictionary
    file which is an ASCII list of legal words also in alphabetical
    order. If the word is not found then it is placed into a file of
    possible misspelled words on disk. The user is then responsible for
    printing the list of misspelled words and using a global change
    feature in a word processor to find and replace the words with the
    correct spelling.

    This spell checker works in much the same way except that a unique
    word file is formed in an array alphabetically as the text file is
    parsed into words. The rest of the process is about the same.

    To use, just type the name of the program followed by parameters
    specifying the source and output files. The parameters are optional
    and if ommitted then the program will request these names.
}

CONST
    WORDSIZE : integer = 16;

TYPE
    FILES = text;
    STRPARAM = string [255];
    WORDTYP = string [16];
    WORDPTR = ^WORDTYP;
    PTRARRAY = array [0..8000] of WORDPTR; {Limited to 8191 because the
                                 Move function requires an integer parameter
                                 for length in bytes of data to move.}

VAR
    SRCNAME : string [36];  { Name of source file to spell check }
    OPPATH : string [24];   { DOS path for speller files }
    OPNAME : string [36];   { DOS name for speller files }
    OUTNAME : string [36];  { Name of output file ( default srcfile.MIS) }
    DOCWORDCNT, UNIQUECNT, MISSPELLCNT : integer;
    I : integer;
    WORDINDX : PTRARRAY;
    WORD, TEMP1 : WORDTYP;
    PREFIX : string [1];
    MATCH : boolean;
    SRCFILE, MISSFILE, DICFILE : FILES;
    x : byte;
    LONGSTRING : string [255]; { working storage for path strings }

FUNCTION LOWCASE (var A : char) : boolean;

{   LOWCASE modifies the character parameter "A" to make it a lower case
    alpha character if it is an upper case alpha. If the character
    parameter is alpha ('a'..'z' or 'A'..'Z') then the function returns
    TRUE else it returns FALSE. }

var x : byte;

begin
    x := ord (A);
    if (x>96) and (x<123) then LOWCASE := true
    else begin
        if (x>64) and (x<91) then
        begin
           A := chr (x+32);
           LOWCASE := true;
        end
        else LOWCASE := false;
    end;
end; { of LOWCASE }

PROCEDURE GETWORD (var FILNAME : FILES; var WORD : WORDTYP);

{GETWORD version 1.2. Defines the start of a word as the next alpha
character in the file. A word is formed by adding characters until a
non-alpha character is found. Contractions are accepted as identified by
a single quote followed by an alpha character occuring after the SOW.
Upper case letters are converted to lower case.}

VAR
    CH, CH2 : char;
    SOW : boolean;
    {Global WORDSIZE = maximum word length value.}
begin
    SOW := false;
    WORD := '';
    repeat
       read (FILNAME, CH);
       if LOWCASE (CH) then SOW := true
    until SOW or eof (FILNAME);
    if SOW then
    begin
       WORD := CH;
       repeat
          read (FILNAME, CH);
          if LOWCASE (CH) then
          begin
             if Length (WORD) < WORDSIZE then WORD := WORD + CH
             else SOW := false;
          end
          else begin
             if CH <> '''' then SOW := false
             else begin
                if not Eof (FILNAME) then
                begin
                   Read (FILNAME, CH2);
                   if LOWCASE (CH2) then
                   begin
                      if Length (WORD) < WORDSIZE-1 then
                         WORD := WORD + CH + CH2 else SOW := false;
                   end
                   else SOW := false;
                end;
             end;
          end;
       until (not SOW) or eof (FILNAME);
    end;
end; { of GETWORD }

procedure ADDUNIQUE (var LIST : PTRARRAY; WORD : WORDTYP; var TOP : integer);

{ This procedure does a binary search of the LIST looking for the location
  where WORD belongs. Once it finds the place, if WORD is there then it exits.
  If not, then it moves the list up by one pointer and puts the new word
  there.}

var
    SEARCH : boolean;
    MID, LOW, HIGH, COUNT : integer;

begin
    SEARCH := true;
    LOW := 0; MID := Trunc (TOP/2); HIGH := TOP;
    while SEARCH do                  {** Find the place where WORD belongs. **}
    begin
       if MID = LOW then SEARCH := false
       else begin
          if WORD < LIST [MID]^ then HIGH := MID
          else LOW := MID;               {** WORD is >= word at LIST [MID]^ **}
          MID := LOW + Trunc ((HIGH-LOW)/2);
       end;
    end; {** of SEARCH. MID is at the location containing WORD or else
              WORD goes at the location after MID. **}
    if WORD <> LIST [MID]^ then begin
       COUNT := 4*(TOP-MID);
       MID := MID+1;
       Move (LIST [MID], LIST [MID+1], COUNT);
       TOP := TOP+1;
       new (LIST [MID]);
       LIST [MID]^ := WORD;
       Gotoxy (20,16);
       Write (TOP);
    end;
end;

Function GetPath : STRPARAM;

{ This procedure extracts the 'PATH =' string from the DOS environment passed
by DOS to the applications program.}

Var
    i, x : Integer;
    EnvSegAdr : Integer absolute CSeg : $002c;
    PathString : String [255];
    Done : Boolean;
Begin;
    I := 0;
    PathString := '';
    Done := false;
    Repeat
       x := Mem [EnvSegAdr : I];
       if x <> 0 then begin
          PathString := PathString + chr (x);
          i := i+1;
          end
       else begin
          i := i+1;
          x := Mem [EnvSegAdr : I];
          if x = 0 then done := true;
          if Pos ('PATH',PathString) = 1 then begin
             Done := true;
             PathString := Copy (PathString, 6, Length (PathString));
          end
          else PathString := '';
       end;
    Until Done;
GetPath := PathString;
end;

Function ParsePath (Var LONGSTRING : STRPARAM) : STRPARAM;

{ This function returns the first substring of LONGSTRING which is terminated
by the end of the string or by a semicolon. It then alters the input variable
LONGSTRING to remove this part of the string. Thus subsequent calls to
ParsePath will return one part of the parameter string until it is all gone
and will then return a nul string. }

var
    x : integer;
begin
    if length (LONGSTRING) = 0 then ParsePath := '' else begin
       x := Pos (';',LONGSTRING);
       if x=0 then begin
          ParsePath := LONGSTRING;
          LONGSTRING := '';
       end
       else begin
          ParsePath := Copy (LONGSTRING, 1, x-1);
          LONGSTRING := Copy (LONGSTRING, x+1, Length (LONGSTRING));
       end;
    end;
end;

begin {*************** MAIN PROGRAM *******************}

DOCWORDCNT := 0; MISSPELLCNT := 0;
clrscr;
gotoxy (10,10);
if ParamCount = 0 then begin
    write ('name of source file : ');
    readln (SRCNAME);
    end
else SRCNAME := ParamStr (1);
clrscr;
gotoxy (10,10);
write ('Opening file :  ');
gotoxy (26,10);
writeln (SRCNAME,'                 ');
assign (SRCFILE, SRCNAME);
reset (SRCFILE);
LONGSTRING := GetPath;
MATCH := false;
OPPATH := '';
PREFIX := '';
while MATCH = false do begin
   OPNAME := OPPATH + PREFIX + 'SPELLER.LIS';
   gotoxy (26,10);
   write (OPNAME,'              ');
   assign (DICFILE, OPNAME);
   {$I-} reset (DICFILE) {$I+};
   x := IOResult;
   MATCH := (x=0);
   OPPATH := ParsePath (LONGSTRING);
   if OPPATH = '' then MATCH := true
   else begin
      if (Pos (':',OPPATH) = Length (OPPATH)) or
         (Pos ('\',OPPATH) = Length (OPPATH)) then PREFIX := ''
      else PREFIX := '\';
   end;
end;
if x<>0 then begin
   writeln;
   writeln ('Unable to locate the spelling list. Aborting SPELLER.');
   close (SRCFILE);
   exit;
end;
I := Pos ('.',SRCNAME);
if I = 0 then OUTNAME := SRCNAME + '.MIS'
         else OUTNAME := Copy (SRCNAME, 1, I-1) + '.MIS';
gotoxy (26,10);
write (OUTNAME,'                 ');
assign (MISSFILE, OUTNAME);
{$I-} rewrite (MISSFILE) {$I+};
if IOResult <> 0 then begin
    writeln;
    writeln ('Unable to open the output file. Error code is ',x);
    writeln ('Program terminating.');
    close (SRCFILE);
    close (DICFILE);
    exit;
    end;
Clrscr;
Gotoxy (37,10);
Write ('READING  ',SRCNAME);
Gotoxy (1,14);
Writeln ('WORDS READ      : '); Writeln;
Writeln ('UNIQUE WORDS    : ');Writeln;
Writeln ('WORDS CHECKED   : ');Writeln;
Write   ('SPELLING ERRORS : ');
UNIQUECNT := 1;
New (WORDINDX [1]);
WORDINDX [2] := nil;
WORDINDX [1]^ := '~';
while not eof (SRCFILE) do begin
    GETWORD (SRCFILE, WORD);
    if WORD <> '' then begin
        Gotoxy (20,14);
        DOCWORDCNT := DOCWORDCNT + 1;
        Write (DOCWORDCNT);
        ADDUNIQUE (WORDINDX, WORD, UNIQUECNT);
    end;
end;
Close (SRCFILE);
{*** Check against dictionary ***}
Gotoxy (30,10);
write ('CHECKING SPELLING                ');
I := 1;
WORD := '';
while I <= UNIQUECNT do begin
    Gotoxy (20,18);
    write (I);
    while (WORD < WORDINDX [I]^) and not Eof (DICFILE) do
       Readln (DICFILE, WORD);
    if WORD <> WORDINDX [I]^ then begin
       Writeln (MISSFILE, WORDINDX [I]^);
       MISSPELLCNT := MISSPELLCNT +1;
       Gotoxy (20,20);
       Write (MISSPELLCNT);
    end;
    I := I + 1;
end { while I <= ... };
Close (DICFILE);
Write (MISSFILE, Chr (26));
Close (MISSFILE);
Gotoxy (1,22);
End.